home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / util / feedback.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  4.8 KB  |  145 lines
  1. structure Feedback : 
  2.     sig val scc : (int * int list) list -> (int * int list) list list 
  3.       (* Strongly-connected components of a graph *)
  4.     val feedback : (int * int list) list -> int list 
  5.       (* Minimum feedback vertex set of a graph *)
  6.     end =
  7. (* Input: A directed graph; that is, a list of vertex-numbers, 
  8.             each node with a list of out-edges which indicate other vertices.
  9.    Output:  A minimum feedback vertex set.
  10.  
  11.    Method: branch and bound
  12.  
  13. *)
  14.  
  15. struct
  16.    
  17. type node = int * int list
  18. type graph = node list
  19.  
  20. val infinity = 1000000000
  21.  
  22. fun minl l =
  23.  let fun f(i,nil) = i | f(i,j::rest) = if i<j then f(i,rest) else f(j,rest)
  24.   in f(infinity,l)
  25.  end
  26.  
  27. fun all (a::rest) = a andalso all rest | all nil = true
  28.  
  29. fun forall nil f = () | forall (a::r) f = (f a; forall r f)
  30.  
  31. fun filter f nil = nil | filter f (x::rest) = if f x then x::filter f rest
  32.                                                      else filter f rest
  33.  
  34. fun scc nil = nil   (* quickie special case; the general case still works
  35.                but is slower *)
  36.   | scc nodes =
  37. let exception Unseen
  38.     type info = {dfsnum: int ref, 
  39.          sccnum: int ref, 
  40.          edges: int list}
  41.     val m : info Intmap.intmap = Intmap.new(32,Unseen)
  42.     val lookup = Intmap.map m
  43.  
  44.     val compnums = ref 0 and id = ref 0
  45.     val comps = ref (nil: (int * int list) list list)
  46.  
  47.     val stack : (int * info) list ref = ref nil
  48.  
  49.     fun scc' nodenum =
  50.     (* Find strongly-connected components of a graph;
  51.        return a list of components; each component is a graph
  52.        with no edges pointing out of the component *)
  53.         let val info as {dfsnum as ref d, sccnum, edges} = lookup nodenum
  54.         (* prune: gets rid of edges out of the component *)
  55.         fun prune c = filter (fn i => !(#sccnum(lookup i)) = c)
  56.  
  57.             fun gather(c,bag,(n' as (n,{sccnum,dfsnum,edges}))::rest) = 
  58.             (sccnum := c; dfsnum := infinity;
  59.              
  60. (*                         print n; print "  "; print c; print "\n"; *)
  61.                          if n=nodenum then (map (fn (n,{edges,...})=>
  62.                              (n, prune c edges))
  63.                          (n'::bag),
  64.                      rest)
  65.                        else gather(c,n'::bag,rest))
  66.         val v = !id 
  67.          in if d >= 0 then d 
  68.         else (id := v+1; 
  69.           stack := (nodenum, info) :: !stack;
  70.                   dfsnum := v;
  71.           let val b = minl(map scc' edges)
  72.            in if v <= b
  73.                       then let val c = !compnums before inc compnums
  74.                    val (newcomp,s) = gather(c,nil,!stack)
  75.                 in stack := s;
  76.                    comps := newcomp :: !comps;
  77.                    v
  78.                end
  79.               else b
  80.           end)
  81.        end
  82.  
  83.  in (*print "\nInput: "; forall nodes (fn (i,_) => (print i; print " "));*)
  84.     forall nodes
  85.      (fn (f,edges) => Intmap.add m 
  86.               (f,{dfsnum=ref ~1, sccnum=ref ~1, edges=edges}));
  87.     forall nodes (fn (vertex,edges) => scc' vertex);
  88. (*    print "\nOutput:";
  89.     forall (!comps) (fn l =>
  90.         (forall l (fn (i:int,_) => (print i; print " "));
  91.      print "; "));
  92.     print "\n";
  93. *)    !comps
  94. end
  95.  
  96. (* A "trivial" component is just a single node with no self loop *)
  97. fun trivial [(_,[])] = true
  98.   | trivial _ = false
  99.  
  100. (*
  101.      val printlist = app( fn i:int => (print i; print " "))
  102.      (print "f "; print lim; print " "; printlist (map #1 left); 
  103.       print "("; print x; print ") "; printlist (map #1 right); print "\n";
  104.     print "try "; print limit; print " "; printlist (map #1 nodes); print "\n";
  105. *)
  106.  
  107. fun feedb(limit, graph: graph) = 
  108.     (* return a minimum feedback vertex set for graph, 
  109.        of size no bigger then limit; else return NONE *)
  110.     let val comps = filter (not o trivial) (scc graph)
  111.         fun g(lim, set, c::comps) = 
  112.           if lim>0 
  113.            then (case try(lim,c)
  114.               of NONE => NONE
  115.                        | SOME vl => g(lim-(length vl - 1), vl@set, comps))
  116.            else NONE
  117.           | g(lim, set, nil) = SOME set
  118.      in g(limit - length comps + 1, nil, comps)
  119.     end
  120.      
  121. and try(limit, nodes: graph) =
  122.     (* "nodes" is a strongly-connected component; remove each node in turn 
  123.        and find the minimum feedback vertex set of the result.
  124.        The resulting set must be no bigger than limit, or don't bother. *)
  125.      let fun f(best,lim,left,nil) = best
  126.            | f(best,lim,left as _::_, (node as (_,[_]))::right) = 
  127.                (* A node with only one out-edge can't be part of
  128.             a unique minimum feedback vertex set, unless they
  129.             all have one out-edge. *)
  130.               f(best,lim,node::left,right)
  131.            | f(best,lim,left,(node as (x,_))::right) = 
  132.               let fun prune (n,el) = (n, filter (fn e=>e<>x) el)
  133.                       val reduced = map prune (left@right)
  134.            in case feedb(lim-1, reduced)
  135.                of SOME vl => f(SOME(x::vl), length vl, 
  136.                        node::left, right)
  137.             | NONE => f(best,lim,node::left,right)
  138.                   end
  139.       in f(NONE, min(limit,length nodes), nil, nodes)
  140.      end
  141.  
  142. fun feedback graph = case feedb(length graph, graph) of SOME set => set
  143.  
  144. end
  145.